home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swags_z.zip / TIMING.SWG / 0020_Dpmi HiRes Timer.pas < prev    next >
Pascal/Delphi Source File  |  1994-08-24  |  5KB  |  166 lines
  1.  
  2. UNIT asytimer;
  3. {Purpose  : High resolution timer which runs asynchronous to the     }
  4. {           rest of the program                                      }
  5. {Author   : Kai Rohrbacher, kai.rohrbacher@logo.ka.sub.org           }
  6. {Language : BorlandPascal 7.0 }
  7. {Date     : 26.06.1994        }
  8. {Remarks  : - Runs both in real- and protected mode.                 }
  9. {           - Only available on AT-style machines or better (uses    }
  10. {             real time clock services)                              }
  11. {           - Will "fall through" on PC's transparently: behaves as  }
  12. {             if time ran off immediately}
  13.  
  14. INTERFACE
  15.  
  16. VAR TimeFlag:^BYTE;
  17.  
  18. FUNCTION ATClockAvailable:BOOLEAN;
  19. PROCEDURE SetCycleTime(microseconds:LONGINT);
  20. FUNCTION TimeOver:BOOLEAN;
  21.   INLINE($C4/$1E/TimeFlag/   {LES BX,TimeFlag}
  22.          $26/$8A/$07/        {MOV AL,ES:[BX] }
  23.          $B1/$07/            {MOV CL,7 }
  24.          $D2/$E8);           {SHR AL,CL}
  25. PROCEDURE Trigger;
  26.  
  27. IMPLEMENTATION
  28.  
  29. USES CRT;
  30.  
  31. {$IFDEF DPMI}
  32. TYPE Treg=RECORD  {stuff for that dumb DPMI-server}
  33.            CASE BYTE OF
  34.             0:(LoLo,LoHi,HiLo,HiHi:BYTE);
  35.             1:(Lo16,Hi16:WORD);
  36.           END;
  37.      Tregisters32=
  38.        RECORD
  39.          EDI,ESI,EBP,junk32,EBX,EDX,ECX,EAX:Treg;
  40.          Flags32,ES,DS,FS,GS,IP,CS,SP,SS:WORD
  41.        END;
  42. VAR regs32:Tregisters32;
  43.  
  44.  FUNCTION EmulateInt(IntNr:BYTE; VAR regs32:Tregisters32):BOOLEAN;
  45.  ASSEMBLER; {emulate real mode interrupt IntNr with registers regs32}
  46.  ASM
  47.    MOV AX,300h   {emulate INT}
  48.    XOR BH,BH     {no A20 gate reset, please}
  49.    MOV BL,IntNr  {INT to emulate}
  50.    XOR CX,CX     {no parameter passing via PM stack}
  51.    LES DI,regs32 {pointer to register set}
  52.    INT 31h       {go for it}
  53.    CMC           {carry flag set if error, reflect this}
  54.    MOV AX,0      {as a BOOLEAN value: return TRUE if C=0}
  55.    ADC AX,AX     {and FALES otherwise}
  56.  END;
  57. {$ENDIF}
  58.  
  59. VAR CycleTimeLo16,CycleTimeHi16:WORD;
  60.     IsAT:BYTE;
  61.  
  62. {$IFDEF DPMI}
  63. FUNCTION ATClockAvailable:BOOLEAN; {protected mode function}
  64. BEGIN
  65.  TimeFlag^:=0;             {reset flag}
  66.  FillChar(regs32,SizeOf(regs32),0);
  67.  regs32.ECX.Lo16:=0;
  68.  regs32.EDX.Lo16:=1;       {trigger flag after 1us}
  69.  regs32.ES      :=$40;     {_segment_ address of Timeflag}
  70.  regs32.EBX.Lo16:=Ofs(TimeFlag^); {offset part = $F0}
  71.  regs32.EAX.Lo16:=$8300;
  72.  
  73.  IF NOT EmulateInt($15,regs32)
  74.   THEN WRITELN('Something went wrong in the INT-emulation!?');
  75.  
  76.  Delay(1); {INT-emulation went ok, look for timer event:}
  77.            {wait 1000us, so event must have happened:}
  78.  {Flag now should have been set to $80:}
  79.  ATClockAvailable:=TimeFlag^=$80;
  80. END;
  81.  
  82. {$ELSE}
  83.  
  84. FUNCTION ATClockAvailable:BOOLEAN; {real mode function}
  85. BEGIN
  86.  TimeFlag^:=0;             {reset flag}
  87.  IF Test8086<>0  {is it at least an AT?}
  88.   THEN ASM {yes, have a closer look:}
  89.          STI
  90.          XOR CX,CX       {trigger after 1us}
  91.          MOV DX,1
  92.          LES BX,TimeFlag {set Flag to $80 after this time}
  93.          MOV AX,8300h    {run asynchron to rest of program}
  94.          INT 15h         {go!}
  95.        END;
  96.  Delay(1);               {wait a 1000us}
  97.  ATClockAvailable:=TimeFlag^=$80 {Flag=$80, if it worked}
  98. END;
  99. {$ENDIF}
  100.  
  101. PROCEDURE SetCycleTime(microseconds:LONGINT);
  102. BEGIN
  103.  TimeFlag^:=$80;
  104.  CycleTimeHi16:=microseconds SHR 16;
  105.  CycleTimeLo16:=microseconds AND $FFFF;
  106.  IF (microseconds<>0) AND ATClockAvailable
  107.   THEN IsAT:=0     {ja, Zeitüberwachung soll benutzt werden  }
  108.   ELSE IsAT:=$80   {nein, keine möglich oder nicht gewünscht }
  109. END;
  110.  
  111. PROCEDURE Trigger;
  112. {starts timer, which must have previously been set by SetCycleTime()}
  113. BEGIN
  114.  IF IsAT<>0 THEN EXIT; {jmp out, if timer services unavailable}
  115.  TimeFlag^:=0;
  116. {$IFDEF DPMI}
  117.  regs32.ECX.Lo16:=CycleTimeHi16;
  118.  regs32.EDX.Lo16:=CycleTimeLo16;  {trigger flag after t us}
  119.  regs32.ES      :=$40;            {_segment_ address of Timeflag}
  120.  regs32.EBX.Lo16:=Ofs(TimeFlag^); {offset part = $F0}
  121.  regs32.EAX.Lo16:=$8300;
  122.  
  123.  IF NOT EmulateInt($15,regs32)
  124.   THEN WRITELN('Something went wrong in the INT-emulation!?');
  125. {$ELSE}
  126. ASM
  127.   MOV CX,CycleTimeHi16
  128.   MOV DX,CycleTimeLo16
  129.   LES BX,TimeFlag {set Flag to $80 after this time}
  130.   MOV AX,8300h    {run asynchron to rest of program}
  131.   INT 15h         {go!}
  132. END;
  133. {$ENDIF}
  134. END;
  135.  
  136. BEGIN
  137.  TimeFlag:=Ptr(Seg0040,$F0); {available byte in 1st MB}
  138.  SetCycleTime(0)
  139. END.
  140.  
  141. ____
  142.  
  143. PROGRAM TestUnit_asytimer;
  144. {Kai Rohrbacher, kai.rohrbacher@logo.ka.sub.org}
  145. USES asytimer;
  146. CONST wait:LONGINT=5000000; {trigger time in us -> 5sec}
  147.  
  148.  PROCEDURE SomeThing;
  149.  CONST s:ARRAY[0..3] OF CHAR='\|/-';
  150.        help:BYTE=0;
  151.  BEGIN WRITE(s[help]+^H); help:=(help+1) AND 3 END;
  152.  
  153. BEGIN
  154.  IF ATClockAvailable
  155.   THEN WRITELN('INT15h-timer-routine available!')
  156.   ELSE WRITELN('INT15h-timer-routine doesn''t work!');
  157.  
  158.  SetCycleTime(wait);
  159.  WRITELN('Between the following 2 bells, there should be a delay of ',
  160.          wait,' microseconds');
  161.  Trigger;    {wait 5s = 5000ms}
  162.  WRITE(#7);
  163.  WHILE NOT TimeOver DO SomeThing;
  164.  WRITELN(#7'Done!');
  165. END.
  166.